home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Error.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  5.0 KB  |  202 lines
  1. package CPANPLUS::Error;
  2.  
  3. use strict;
  4.  
  5. use Log::Message private => 0;;
  6.  
  7. =pod
  8.  
  9. =head1 NAME
  10.  
  11. CPANPLUS::Error
  12.  
  13. =head1 SYNOPSIS
  14.  
  15.     use CPANPLUS::Error qw[cp_msg cp_error];
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. This module provides the error handling code for the CPANPLUS
  20. libraries, and is mainly intended for internal use.
  21.  
  22. =head1 FUNCTIONS
  23.  
  24. =head2 cp_msg("message string" [,VERBOSE])
  25.  
  26. Records a message on the stack, and prints it to C<STDOUT> (or actually
  27. C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
  28. C<VERBOSE> option is true.
  29. The C<VERBOSE> option defaults to false.
  30.  
  31. =head2 msg()
  32.  
  33. An alias for C<cp_msg>.
  34.  
  35. =head2 cp_error("error string" [,VERBOSE])
  36.  
  37. Records an error on the stack, and prints it to C<STDERR> (or actually
  38. C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
  39. C<VERBOSE> option is true.
  40. The C<VERBOSE> options defaults to true.
  41.  
  42. =head2 error()
  43.  
  44. An alias for C<cp_error>.
  45.  
  46. =head1 CLASS METHODS
  47.  
  48. =head2 CPANPLUS::Error->stack()
  49.  
  50. Retrieves all the items on the stack. Since C<CPANPLUS::Error> is
  51. implemented using C<Log::Message>, consult its manpage for the
  52. function C<retrieve> to see what is returned and how to use the items.
  53.  
  54. =head2 CPANPLUS::Error->stack_as_string([TRACE])
  55.  
  56. Returns the whole stack as a printable string. If the C<TRACE> option is
  57. true all items are returned with C<Carp::longmess> output, rather than
  58. just the message.
  59. C<TRACE> defaults to false.
  60.  
  61. =head2 CPANPLUS::Error->flush()
  62.  
  63. Removes all the items from the stack and returns them. Since
  64. C<CPANPLUS::Error> is  implemented using C<Log::Message>, consult its
  65. manpage for the function C<retrieve> to see what is returned and how
  66. to use the items.
  67.  
  68. =cut
  69.  
  70. BEGIN {
  71.     use Exporter;
  72.     use Params::Check   qw[check];
  73.     use vars            qw[@EXPORT @ISA $ERROR_FH $MSG_FH];
  74.  
  75.     @ISA        = 'Exporter';
  76.     @EXPORT     = qw[cp_error cp_msg error msg];
  77.  
  78.     my $log     = new Log::Message;
  79.  
  80.     for my $func ( @EXPORT ) {
  81.         no strict 'refs';
  82.         
  83.         my $prefix  = 'cp_';
  84.         my $name    = $func;
  85.         $name       =~ s/^$prefix//g;
  86.         
  87.         *$func = sub {
  88.                         my $msg     = shift;
  89.                         
  90.                         ### no point storing non-messages
  91.                         return unless defined $msg;
  92.                         
  93.                         $log->store(
  94.                                 message => $msg,
  95.                                 tag     => uc $name,
  96.                                 level   => $prefix . $name,
  97.                                 extra   => [@_]
  98.                         );
  99.                 };
  100.     }
  101.  
  102.     sub flush {
  103.         return reverse $log->flush;
  104.     }
  105.  
  106.     sub stack {
  107.         return $log->retrieve( chrono => 1 );
  108.     }
  109.  
  110.     sub stack_as_string {
  111.         my $class = shift;
  112.         my $trace = shift() ? 1 : 0;
  113.  
  114.         return join $/, map {
  115.                         '[' . $_->tag . '] [' . $_->when . '] ' .
  116.                         ($trace ? $_->message . ' ' . $_->longmess
  117.                                 : $_->message);
  118.                     } __PACKAGE__->stack;
  119.     }
  120. }
  121.  
  122. =head1 GLOBAL VARIABLES
  123.  
  124. =over 4
  125.  
  126. =item $ERROR_FH
  127.  
  128. This is the filehandle all the messages sent to C<error()> are being
  129. printed. This defaults to C<*STDERR>.
  130.  
  131. =item $MSG_FH
  132.  
  133. This is the filehandle all the messages sent to C<msg()> are being
  134. printed. This default to C<*STDOUT>.
  135.  
  136. =cut
  137. local $| = 1;
  138. $ERROR_FH   = \*STDERR;
  139. $MSG_FH     = \*STDOUT;
  140.  
  141. package Log::Message::Handlers;
  142. use Carp ();
  143.  
  144. {
  145.  
  146.     sub cp_msg {
  147.         my $self    = shift;
  148.         my $verbose = shift;
  149.  
  150.         ### so you don't want us to print the msg? ###
  151.         return if defined $verbose && $verbose == 0;
  152.  
  153.         my $old_fh = select $CPANPLUS::Error::MSG_FH;
  154.  
  155.         print '['. $self->tag . '] ' . $self->message . "\n";
  156.         select $old_fh;
  157.  
  158.         return;
  159.     }
  160.  
  161.     sub cp_error {
  162.         my $self    = shift;
  163.         my $verbose = shift;
  164.  
  165.         ### so you don't want us to print the error? ###
  166.         return if defined $verbose && $verbose == 0;
  167.  
  168.         my $old_fh = select $CPANPLUS::Error::ERROR_FH;
  169.  
  170.         ### is only going to be 1 for now anyway ###
  171.         ### C::I may not be loaded, so do a can() check first
  172.         my $cb      = CPANPLUS::Internals->can('_return_all_objects')
  173.                         ? (CPANPLUS::Internals->_return_all_objects)[0]
  174.                         : undef;
  175.  
  176.         ### maybe we didn't initialize an internals object (yet) ###
  177.         my $debug   = $cb ? $cb->configure_object->get_conf('debug') : 0;
  178.         my $msg     =  '['. $self->tag . '] ' . $self->message . "\n";
  179.  
  180.         ### i'm getting this warning in the test suite:
  181.         ### Ambiguous call resolved as CORE::warn(), qualify as such or
  182.         ### use & at CPANPLUS/Error.pm line 57.
  183.         ### no idea where it's coming from, since there's no 'sub warn'
  184.         ### anywhere to be found, but i'll mark it explicitly nonetheless
  185.         ### --kane
  186.         print $debug ? Carp::shortmess($msg) : $msg . "\n";
  187.  
  188.         select $old_fh;
  189.  
  190.         return;
  191.     }
  192. }
  193.  
  194. 1;
  195.  
  196. # Local variables:
  197. # c-indentation-style: bsd
  198. # c-basic-offset: 4
  199. # indent-tabs-mode: nil
  200. # End:
  201. # vim: expandtab shiftwidth=4:
  202.